home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
TeX 1995 July
/
TeX CD-ROM July 1995 (Disc 1)(Walnut Creek)(1995).ISO
/
macros
/
musictex
/
older-versions
/
musictex.503
/
SORTINDX.FOR
< prev
Wrap
Text File
|
1993-06-06
|
21KB
|
643 lines
PROGRAM SORTINDX
IMPLICIT INTEGER(A-Z)
PARAMETER(LLTH=255,MTAB=700,TLTH=100)
PARAMETER(ZLTH=128000/MTAB)
CHARACTER*(LLTH) LIGNE,CLIGNE
CHARACTER*(TLTH) FTABL(MTAB)
CHARACTER*(ZLTH) TABLE(MTAB)
CHARACTER*(LLTH) TEXTI,TEXTJ
CHARACTER*1 MAJUSC(0:255)
INTEGER LETTER(0:255),DIGIT(0:255)
INTEGER ORDNO(MTAB)
CHARACTER*64 INPUT,OUTPUT,OPTION
CHARACTER*(*) INDEXENTRY
LOGICAL REPACK,UPCASE_COMP
PARAMETER (INDEXENTRY='\indexentry')
CHARACTER*64 END_SKIP
C
LENTRY=LEN(INDEXENTRY)
LANGUAGE=0
REPACK=.FALSE.
UPCASE_COMP=.TRUE.
C 0=anglais, 1=francais, 2=allemand 3=espagnol 4=italien
C unix: NARGS=IARGC()
C DOS 5.0: NUMARGS=NARGS()-1
NUMARGS=NARGS()-1
INPUT=' '
OUTPUT=' '
END_SKIP=' '
DO 15 J=1,NUMARGS
CALL GETARG(J,OPTION,KSTAT)
IF(OPTION(1:1) .NE. '-') THEN
IF(INPUT .EQ. ' ') THEN
INPUT=OPTION
ELSE IF(OUTPUT .EQ. ' ') THEN
OUTPUT=OPTION
ELSE
PRINT *,'Exceeding parameter:',OPTION(:TRIMLN(OPTION))
END IF
ELSE IF(OPTION .EQ. '-e') THEN
LANGUAGE=0
ELSE IF(OPTION .EQ. '-f') THEN
LANGUAGE=1
ELSE IF(OPTION .EQ. '-g') THEN
LANGUAGE=2
ELSE IF(OPTION .EQ. '-s') THEN
LANGUAGE=3
ELSE IF(OPTION .EQ. '-i') THEN
LANGUAGE=4
ELSE IF(OPTION .EQ. '-A') THEN
REPACK=.TRUE.
ELSE IF(OPTION .EQ. '-C') THEN
UPCASE_COMP=.FALSE.
ELSE IF(OPTION(1:2) .EQ. '-X' .AND. OPTION(3:).NE.' ')THEN
END_SKIP=OPTION(3:)
ELSE IF(OPTION .EQ. '-h') THEN
PRINT *,'Sortindx, version 1.2 - D. Taupin'
PRINT *,' '
PRINT *,' SORTINDX [options] <input-file> <output-file> ',
$ '[options]'
PRINT *,' '
PRINT *,'Options: -e : english alphabetical order'
PRINT *,'Options: -f : french alphabetical order'
PRINT *,'Options: -g : german alphabetical order'
PRINT *,'Options: -h : this help'
PRINT *,'Options: -i : italian alphabetical order'
PRINT *,'Options: -s : spanish alphabetical order ~n/ch/ll'
PRINT *,'Options: -A : repack spaces and {\accent x x}'
PRINT *,'Options: -C : case dependent sorting (A>z)'
PRINT *,'Options: -X<string> : eliminate index entry text',
$ ' until <string> (included)'
PRINT *,' in sorted file'
PRINT *,'------------- RETURN KEY TO RESUME ------------'
READ '(A)',OPTION
ELSE
PRINT *,'Illegal option:',OPTION(:TRIMLN(OPTION))
STOP
END IF
15 CONTINUE
C
PRINT *,'input :',INPUT
PRINT *,'output:',OUTPUT
PRINT *,'language=',LANGUAGE
C
DO 40 I=0,255
LETTER(I)=0
MAJUSC(I)=CHAR(I)
DIGIT(I)=-1
40 CONTINUE
MAJMIN=ICHAR('A')-ICHAR('a')
J=0
DO 41 I=ICHAR('A'),ICHAR('I')
J=J+1
LETTER(I)=J
MAJUSC(I-MAJMIN)=CHAR(I)
41 CONTINUE
DO 42 I=ICHAR('J'),ICHAR('R')
J=J+1
LETTER(I)=J
MAJUSC(I-MAJMIN)=CHAR(I)
42 CONTINUE
DO 43 I=ICHAR('S'),ICHAR('Z')
J=J+1
LETTER(I)=J
MAJUSC(I-MAJMIN)=CHAR(I)
43 CONTINUE
J=0
DO 44 I=ICHAR('0'),ICHAR('9')
DIGIT(I)=J
J=J+1
44 CONTINUE
OPEN(8,FILE=INPUT,IOSTAT=IZ,STATUS='OLD')
IF(IZ .NE. 0) THEN
PRINT *,'Open error ',INPUT,IZ
STOP
END IF
OPEN(9,FILE=OUTPUT,IOSTAT=IZ,STATUS='UNKNOWN')
IF(IZ .NE. 0) THEN
PRINT *,'Open error ',OUTPUT,IZ
STOP
END IF
C
C
END_SKIPL=TRIMLN(END_SKIP)
NI=0
100 CONTINUE
READ (8,101,END=200) LIGNE
IF(LIGNE .EQ. ' ') GO TO 100
101 FORMAT(A)
IA=INDEX(LIGNE,INDEXENTRY)
IF(IA .EQ. 0) THEN
PRINT *,'No \indexentry{ in input line:',LIGNE(:TRIMLN(LIGNE))
PRINT *,'... ignored'
GO TO 100
END IF
C pointer sur le debut du texte
IA=IA+INDEX(LIGNE(IA:),'{')
C
C ELIMINATION DES ACCENTS
C
TEXTI=LIGNE
CALL SUBSTI(TEXTI,'{ ','{',255)
CALL SUBSTI(TEXTI,'{} ',' ',255)
CALL SUBSTI(TEXTI,'\protect \','\',255)
CALL SUBSTI(TEXTI,'\protect\','\',255)
CALL SUBSTI(TEXTI,'\OE ','OE',10)
CALL SUBSTI(TEXTI,'\AE ','AE',10)
CALL SUBSTI(TEXTI,'\i }','I}',10)
CALL SUBSTI(TEXTI,'\oe ','OE',10)
CALL SUBSTI(TEXTI,'\ae ','AE',10)
CALL SUBSTI(TEXTI,'\ss ','SS',10)
CALL SUBSTI(TEXTI,'^^ff','SS',10)
CALL SUBSTI(TEXTI,'^^df','SS',10)
CALL SUBSTI(TEXTI,'^^^','OE',10)
CALL SUBSTI(TEXTI,'^^]','AE',10)
CALL SUBSTI(TEXTI,'\i ','I',10)
CALL SUBSTI(TEXTI,'^^P','I',10)
CALL SUBSTI(TEXTI,'^^[','OE',10)
CALL SUBSTI(TEXTI,'^^Z','AE',10)
CALL SUBSTI(TEXTI,'^^Y','SS',10)
CALL SUBSTI(TEXTI,'^^_','O',10)
CALL SUBSTI(TEXTI,'^^\','O',10)
C lettres accentuees PC
CALL SUBSTI(TEXTI,'à','A',255)
CALL SUBSTI(TEXTI,'ä','A',255)
CALL SUBSTI(TEXTI,'â','A',255)
CALL SUBSTI(TEXTI,'╖','A',255)
CALL SUBSTI(TEXTI,'╢','A',255)
CALL SUBSTI(TEXTI,'Ä','A',255)
CALL SUBSTI(TEXTI,'é','E',255)
CALL SUBSTI(TEXTI,'è','E',255)
CALL SUBSTI(TEXTI,'ê','E',255)
CALL SUBSTI(TEXTI,'ë','E',255)
CALL SUBSTI(TEXTI,'É','E',255)
CALL SUBSTI(TEXTI,'╘','E',255)
CALL SUBSTI(TEXTI,'╥','E',255)
CALL SUBSTI(TEXTI,'╙','E',255)
CALL SUBSTI(TEXTI,'╪','I',255)
CALL SUBSTI(TEXTI,'ï','I',255)
CALL SUBSTI(TEXTI,'╫','I',255)
CALL SUBSTI(TEXTI,'î','I',255)
CALL SUBSTI(TEXTI,'ö','O',255)
CALL SUBSTI(TEXTI,'Ö','O',255)
CALL SUBSTI(TEXTI,'ô','O',255)
CALL SUBSTI(TEXTI,'Γ','O',255)
CALL SUBSTI(TEXTI,'ü','U',255)
CALL SUBSTI(TEXTI,'Ü','U',255)
CALL SUBSTI(TEXTI,'û','U',255)
CALL SUBSTI(TEXTI,'ù','U',255)
CALL SUBSTI(TEXTI,'Ω','U',255)
CALL SUBSTI(TEXTI,'ÿ','Y',255)
CALL SUBSTI(TEXTI,'Θ','U',255)
CALL SUBSTI(TEXTI,'ç','C',255)
CALL SUBSTI(TEXTI,'Ç','C',255)
C lettres accentuees codage ASCII
CALL SUBSTI(TEXTI,'\`a','A',255)
CALL SUBSTI(TEXTI,'\"a','A',255)
CALL SUBSTI(TEXTI,'\^a','A',255)
CALL SUBSTI(TEXTI,'\`A','A',255)
CALL SUBSTI(TEXTI,'\"A','A',255)
CALL SUBSTI(TEXTI,'\^A','A',255)
CALL SUBSTI(TEXTI,'\''e','E',255)
CALL SUBSTI(TEXTI,'\`e','E',255)
CALL SUBSTI(TEXTI,'\^e','E',255)
CALL SUBSTI(TEXTI,'\"e','E',255)
CALL SUBSTI(TEXTI,'\''E','E',255)
CALL SUBSTI(TEXTI,'\`E','E',255)
CALL SUBSTI(TEXTI,'\^E','E',255)
CALL SUBSTI(TEXTI,'\"E','E',255)
CALL SUBSTI(TEXTI,'\^i','I',255)
CALL SUBSTI(TEXTI,'\^I','I',255)
CALL SUBSTI(TEXTI,'\"i','I',255)
CALL SUBSTI(TEXTI,'\"I','I',255)
CALL SUBSTI(TEXTI,'\"o','O',255)
CALL SUBSTI(TEXTI,'\"O','O',255)
CALL SUBSTI(TEXTI,'\^o','O',255)
CALL SUBSTI(TEXTI,'\^O','O',255)
CALL SUBSTI(TEXTI,'\"u','U',255)
CALL SUBSTI(TEXTI,'\"U','U',255)
CALL SUBSTI(TEXTI,'\^u','U',255)
CALL SUBSTI(TEXTI,'\^U','U',255)
CALL SUBSTI(TEXTI,'\`u','U',255)
CALL SUBSTI(TEXTI,'\`U','U',255)
CALL SUBSTI(TEXTI,'\"y','Y',255)
CALL SUBSTI(TEXTI,'\"Y','Y',255)
C lettres accentuees au standard de Cork
CALL SUBSTI(TEXTI,'^^c0','A',255)
CALL SUBSTI(TEXTI,'^^c1','A',255)
CALL SUBSTI(TEXTI,'^^c2','A',255)
CALL SUBSTI(TEXTI,'^^c3','A',255)
CALL SUBSTI(TEXTI,'^^c4','A',255)
CALL SUBSTI(TEXTI,'^^c5','A',255)
CALL SUBSTI(TEXTI,'^^c6','AE',255)
CALL SUBSTI(TEXTI,'^^c7','C',255)
CALL SUBSTI(TEXTI,'^^c8','E',255)
CALL SUBSTI(TEXTI,'^^c9','E',255)
CALL SUBSTI(TEXTI,'^^ca','E',255)
CALL SUBSTI(TEXTI,'^^cb','E',255)
CALL SUBSTI(TEXTI,'^^cc','I',255)
CALL SUBSTI(TEXTI,'^^cd','I',255)
CALL SUBSTI(TEXTI,'^^ce','I',255)
CALL SUBSTI(TEXTI,'^^cf','I',255)
IF(LANGUAGE .EQ. 3) THEN
CALL SUBSTI(TEXTI,'^^d1','N[',255)
ELSE
CALL SUBSTI(TEXTI,'^^d1','N',255)
END IF
CALL SUBSTI(TEXTI,'^^d2','O',255)
CALL SUBSTI(TEXTI,'^^d3','O',255)
CALL SUBSTI(TEXTI,'^^d4','O',255)
CALL SUBSTI(TEXTI,'^^d5','O',255)
CALL SUBSTI(TEXTI,'^^d6','O',255)
CALL SUBSTI(TEXTI,'^^d7','OE',255)
CALL SUBSTI(TEXTI,'^^d8','O',255)
CALL SUBSTI(TEXTI,'^^d9','U',255)
CALL SUBSTI(TEXTI,'^^da','U',255)
CALL SUBSTI(TEXTI,'^^db','U',255)
CALL SUBSTI(TEXTI,'^^dc','U',255)
CALL SUBSTI(TEXTI,'^^dd','Y',255)
CALL SUBSTI(TEXTI,'^^df','SS',255)
CALL SUBSTI(TEXTI,'^^e0','A',255)
CALL SUBSTI(TEXTI,'^^e2','A',255)
CALL SUBSTI(TEXTI,'^^e3','A',255)
CALL SUBSTI(TEXTI,'^^e4','A',255)
CALL SUBSTI(TEXTI,'^^e5','A',255)
CALL SUBSTI(TEXTI,'^^6e','AE',255)
CALL SUBSTI(TEXTI,'^^e7','C',255)
CALL SUBSTI(TEXTI,'^^e8','E',255)
CALL SUBSTI(TEXTI,'^^e9','E',255)
CALL SUBSTI(TEXTI,'^^ea','E',255)
CALL SUBSTI(TEXTI,'^^eb','E',255)
CALL SUBSTI(TEXTI,'^^ec','I',255)
CALL SUBSTI(TEXTI,'^^ed','I',255)
CALL SUBSTI(TEXTI,'^^ee','I',255)
CALL SUBSTI(TEXTI,'^^ef','I',255)
IF(LANGUAGE .EQ. 3) THEN
CALL SUBSTI(TEXTI,'^^f1','N[',255)
ELSE
CALL SUBSTI(TEXTI,'^^f1','N',255)
END IF
CALL SUBSTI(TEXTI,'^^f2','O',255)
CALL SUBSTI(TEXTI,'^^f3','O',255)
CALL SUBSTI(TEXTI,'^^f4','O',255)
CALL SUBSTI(TEXTI,'^^f5','O',255)
CALL SUBSTI(TEXTI,'^^f6','O',255)
CALL SUBSTI(TEXTI,'^^f7','OE',255)
CALL SUBSTI(TEXTI,'^^f9','U',255)
CALL SUBSTI(TEXTI,'^^fa','U',255)
CALL SUBSTI(TEXTI,'^^fb','U',255)
CALL SUBSTI(TEXTI,'^^fc','U',255)
CALL SUBSTI(TEXTI,'^^fd','Y',255)
C version EURO TEX
C lettres accentuees au standard de Cork
CALL SUBSTI(TEXTI,'\char "C0{}','A',255)
CALL SUBSTI(TEXTI,'\char "C1{}','A',255)
CALL SUBSTI(TEXTI,'\char "C2{}','A',255)
CALL SUBSTI(TEXTI,'\char "C3{}','A',255)
CALL SUBSTI(TEXTI,'\char "C4{}','A',255)
CALL SUBSTI(TEXTI,'\char "C5{}','A',255)
CALL SUBSTI(TEXTI,'\char "C6{}','AE',255)
CALL SUBSTI(TEXTI,'\char "C7{}','C',255)
CALL SUBSTI(TEXTI,'\char "C8{}','E',255)
CALL SUBSTI(TEXTI,'\char "C9{}','E',255)
CALL SUBSTI(TEXTI,'\char "CA{}','E',255)
CALL SUBSTI(TEXTI,'\char "CB{}','E',255)
CALL SUBSTI(TEXTI,'\char "CC{}','I',255)
CALL SUBSTI(TEXTI,'\char "CD{}','I',255)
CALL SUBSTI(TEXTI,'\char "CE{}','I',255)
CALL SUBSTI(TEXTI,'\char "CF{}','I',255)
IF(LANGUAGE .EQ. 3) THEN
CALL SUBSTI(TEXTI,'\char "D1{}','N[',255)
ELSE
CALL SUBSTI(TEXTI,'\char "D1{}','N',255)
END IF
CALL SUBSTI(TEXTI,'\char "D2{}','O',255)
CALL SUBSTI(TEXTI,'\char "D3{}','O',255)
CALL SUBSTI(TEXTI,'\char "D4{}','O',255)
CALL SUBSTI(TEXTI,'\char "D5{}','O',255)
CALL SUBSTI(TEXTI,'\char "D6{}','O',255)
CALL SUBSTI(TEXTI,'\char "D7{}','OE',255)
CALL SUBSTI(TEXTI,'\char "D8{}','O',255)
CALL SUBSTI(TEXTI,'\char "D9{}','U',255)
CALL SUBSTI(TEXTI,'\char "DA{}','U',255)
CALL SUBSTI(TEXTI,'\char "DB{}','U',255)
CALL SUBSTI(TEXTI,'\char "DC{}','U',255)
CALL SUBSTI(TEXTI,'\char "DD{}','Y',255)
CALL SUBSTI(TEXTI,'\char "DF{}','SS',255)
CALL SUBSTI(TEXTI,'\char "E0{}','A',255)
CALL SUBSTI(TEXTI,'\char "E2{}','A',255)
CALL SUBSTI(TEXTI,'\char "E3{}','A',255)
CALL SUBSTI(TEXTI,'\char "E4{}','A',255)
CALL SUBSTI(TEXTI,'\char "E5{}','A',255)
CALL SUBSTI(TEXTI,'\char "6E{}','AE',255)
CALL SUBSTI(TEXTI,'\char "E7{}','C',255)
CALL SUBSTI(TEXTI,'\char "E8{}','E',255)
CALL SUBSTI(TEXTI,'\char "E9{}','E',255)
CALL SUBSTI(TEXTI,'\char "EA{}','E',255)
CALL SUBSTI(TEXTI,'\char "EB{}','E',255)
CALL SUBSTI(TEXTI,'\char "EC{}','I',255)
CALL SUBSTI(TEXTI,'\char "ED{}','I',255)
CALL SUBSTI(TEXTI,'\char "EE{}','I',255)
CALL SUBSTI(TEXTI,'\char "EF{}','I',255)
IF(LANGUAGE .EQ. 3) THEN
CALL SUBSTI(TEXTI,'\char "F1{}','N[',255)
ELSE
CALL SUBSTI(TEXTI,'\char "F1{}','N',255)
END IF
CALL SUBSTI(TEXTI,'\char "F2{}','O',255)
CALL SUBSTI(TEXTI,'\char "F3{}','O',255)
CALL SUBSTI(TEXTI,'\char "F4{}','O',255)
CALL SUBSTI(TEXTI,'\char "F5{}','O',255)
CALL SUBSTI(TEXTI,'\char "F6{}','O',255)
CALL SUBSTI(TEXTI,'\char "F7{}','OE',255)
CALL SUBSTI(TEXTI,'\char "F9{}','U',255)
CALL SUBSTI(TEXTI,'\char "FA{}','U',255)
CALL SUBSTI(TEXTI,'\char "FB{}','U',255)
CALL SUBSTI(TEXTI,'\char "FC{}','U',255)
CALL SUBSTI(TEXTI,'\char "FD{}','Y',255)
C
C alphabet espagnol
IF(LANGUAGE .EQ. 3) THEN
CALL SUBSTI(TEXTI,'ll','l[',10)
CALL SUBSTI(TEXTI,'Ll','L[',10)
CALL SUBSTI(TEXTI,'CH','C[',10)
CALL SUBSTI(TEXTI,'Ch','C[',10)
CALL SUBSTI(TEXTI,'ch','c[',10)
END IF
CALL SUBSTI(TEXTI,' \penalty \@M \ ',' ',4)
CALL SUBSTI(TEXTI,'\penalty \@M \ ',' ',4)
CALL SUBSTI(TEXTI,'\hbox to\z@ {\char 24\hss }c','c',8)
CALL SUBSTI(TEXTI,
$ '\hbox to\z@ {\kern 0.1em\char 24\hss }C','C',8)
105 CONTINUE
IACC=INDEX(TEXTI,'{\accent ')
IF(IACC .GT. 0) THEN
IBCC=INDEX(TEXTI(IACC+1:),'}')+IACC
IF(TEXTI(IBCC:IBCC) .NE. '}') THEN
PRINT *,'Clobbered IBCC:',TEXTI(IBCC:IBCC)
STOP
END IF
TEXTJ=TEXTI(IBCC+1:)
TEXTI(IACC:IACC)=TEXTI(IBCC-1:IBCC-1)
TEXTI(IACC+1:)=TEXTJ
PRINT *,TEXTI(:TRIMLN(TEXTI))
GO TO 105
END IF
ICED=INDEX(TEXTI,'\setbox \z@ \hbox')
IF(ICED .NE. 0) THEN
IA24=INDEX(TEXTI,'accent 24 ')
IF(IA24 .NE. 0) THEN
TEXTJ=TEXTI(IA24+10:)
TEXTI(ICED:)=TEXTJ
PRINT *,TEXTI(:TRIMLN(TEXTI))
GO TO 105
END IF
END IF
C
C recherche des deux chaines
C
IB=0
IACCOL=1
DO 80 K=IA,LEN(TEXTI)
IF(TEXTI(K-1:K-1) .NE. '\') THEN
IF(TEXTI(K:K) .EQ. '{') THEN
IACCOL=IACCOL+1
ELSE IF(TEXTI(K:K) .EQ. '}') THEN
IACCOL=IACCOL-1
IF(IACCOL .EQ. 0) THEN
IB=K
GO TO 81
END IF
END IF
END IF
80 CONTINUE
81 CONTINUE
IF(IB .LE. IA) THEN
PRINT *,'Empty item or unbalanced braces:',
$ TEXTI(:TRIMLN(TEXTI))
GO TO 100
END IF
C
IF(TEXTI(IB+1:IB+1) .NE. '{') THEN
PRINT *,'Missing second argument oe \indexentry:',
$ TEXTI(:TRIMLN(TEXTI))
GO TO 100
END IF
IC=INDEX(TEXTI(IB+1:),'}')
IF(IC .LE. 0) THEN
PRINT *,'Unbalanced braces:',
$ TEXTI(:TRIMLN(TEXTI))
GO TO 100
END IF
IC=IC+IB
IF(TEXTI(IC:IC) .NE. '}') THEN
PRINT *,'Clobbered IC ',TEXTI(IC:IC)
STOP
END IF
IF(IC-IB .LE. 2) THEN
PRINT *,'Empty second arg:',
$ TEXTI(:TRIMLN(TEXTI))
GO TO 100
END IF
C
C convertir la zone de comparaison en majuscules
C
IF(UPCASE_COMP) THEN
DO 140 IT=IA,IB-1
TEXTI(IT:IT)=MAJUSC(ICHAR(TEXTI(IT:IT)))
140 CONTINUE
END IF
C
C trouve la limite de la chaine de comparaison
C
DO 120 K=1,NI
IF(TEXTI(IA:IB-1) .EQ. FTABL(K)) THEN
C recherche de la fin du premier argument dans TABLE
CLIGNE=TABLE(K)
JB=0
IACCOL=0
DO 85 KK=1,LEN(CLIGNE)
IF(CLIGNE(KK-1:KK-1) .NE. '\') THEN
IF(CLIGNE(KK:KK) .EQ. '{') THEN
IACCOL=IACCOL+1
ELSE IF(CLIGNE(KK:KK) .EQ. '}') THEN
IACCOL=IACCOL-1
IF(IACCOL .EQ. 0) THEN
JB=KK
GO TO 86
END IF
END IF
END IF
85 CONTINUE
86 CONTINUE
C PRINT *,'''',TEXTI(IB+1:IC),''''
IF(JB .EQ. 0) PRINT *,JB,CLIGNE(JB:),'#'
IF(INDEX(CLIGNE(JB:),TEXTI(IB+1:IC)) .NE. 0) THEN
PRINT *,'Duplicate reference: ',LIGNE(:TRIMLN(LIGNE))
GO TO 100
END IF
ZQ=TRIMLN(TABLE(K))
TABLE(K)(ZQ+1:)=','//TEXTI(IB+1:IC)
GO TO 100
END IF
120 CONTINUE
IF(NI .GE. MTAB) THEN
PRINT *,'Table overflow, max:',MTAB
GO TO 200
END IF
NI=NI+1
ORDNO(NI)=NI
ZZFC=INDEX(LIGNE,'{')
TABLE(NI)=LIGNE(ZZFC:)
FTABL(NI)=TEXTI(IA:IB-1)
GO TO 100
C
200 CONTINUE
CLOSE(8)
PRINT *,'Now sorting'
C
C CLASSEMENT
C
C transformation en majuscules pour classement
C
DO 185 I=1,NI
TEXTI=FTABL(I)
DO 186 IT=1,TRIMLN(TEXTI)
TEXTI(IT:IT)=MAJUSC(ICHAR(TEXTI(IT:IT)))
186 CONTINUE
FTABL(I)=TEXTI
185 CONTINUE
C
ISTEP=NI/3+1
DO 201 ZZ=1,NI*2
DESORD=0
ISTEP=ISTEP/3+1
DO 210 I=1,NI-ISTEP
II=ORDNO(I)
JJ=ORDNO(I+ISTEP)
TEXTI=FTABL(II)
TEXTJ=FTABL(JJ)
IF(LLT(TEXTJ,TEXTI)) THEN
DESORD=1
ORDNO(I)=JJ
ORDNO(I+ISTEP)=II
END IF
210 CONTINUE
IF(DESORD .EQ. 0 .AND. ISTEP .EQ. 1) GO TO 202
201 CONTINUE
PRINT *,'failing sort',CHAR(6)
202 CONTINUE
DO 300 I=1,NI
CLIGNE='\indexentry'//TABLE(ORDNO(I))
IF(END_SKIPL .NE. 0) THEN
IDEB=INDEX(CLIGNE,END_SKIP(1:END_SKIPL))
IF(IDEB .NE. 0) THEN
TEXTI=CLIGNE(IDEB+END_SKIPL:)
CLIGNE=INDEXENTRY//'{'//TEXTI
CALL SUBSTI(CLIGNE,'{ ',' ',15)
END IF
END IF
CALL SUBSTI(CLIGNE,'},{',', ',255)
IF(REPACK) THEN
CALL SUBSTI(CLIGNE,'{\accent 94 ^^P}','^^ce',255)
CALL SUBSTI(CLIGNE,'\hbox to\z@ {\char 24\hss }','\c ',255)
CALL SUBSTI(CLIGNE,'{\accent 18 ','\`{',255)
CALL SUBSTI(CLIGNE,'{\accent 19 ','\''{',255)
CALL SUBSTI(CLIGNE,'{\accent 94 ','\^{',255)
CALL SUBSTI(CLIGNE,'{\accent 127 ','\"{',255)
END IF
C
WRITE(9,101) CLIGNE(:TRIMLN(CLIGNE))
PRINT 102,FTABL(ORDNO(I))(:TRIMLN(FTABL(ORDNO(I))))
102 FORMAT(1X,A)
300 CONTINUE
CLOSE(9)
STOP
END
INTEGER FUNCTION TRIMLN(A)
IMPLICIT INTEGER(A-Z)
CHARACTER*(*) A
C
TRIMLN=LEN(A)
100 CONTINUE
IF(TRIMLN .LE. 0) RETURN
IF(A(TRIMLN:TRIMLN) .EQ. ' ') THEN
TRIMLN=TRIMLN-1
GO TO 100
END IF
RETURN
END
SUBROUTINE FLDEXT(CMDSTR,EXT)
IMPLICIT INTEGER(A-Z)
CHARACTER*(*) CMDSTR,EXT
C
IV=MINDEX(CMDSTR,',')
IF(IV .GT. 1) THEN
EXT=CMDSTR(:IV-1)
ELSE
EXT=' '
END IF
CMDSTR(:IV)=' '
DO 20 Z=1,LEN(CMDSTR)-IV
CMDSTR(Z:Z)=CMDSTR(Z+IV:Z+IV)
20 CONTINUE
Z=LEN(CMDSTR)-IV+1
CMDSTR(Z:)=' '
DO 10 I=1,4
IF(EXT(1:1) .NE. '#') RETURN
EXT(1:1)=' '
CALL LJSTRG(EXT)
10 CONTINUE
RETURN
END
SUBROUTINE LJSTRG(A)
IMPLICIT INTEGER(A-Z)
CHARACTER*(*) A
CHARACTER*1 U
Z=0
LTH=LEN(A)
DO 10 I=1,LTH
U=A(I:I)
IF(ICHAR(U) .GT. ICHAR(' ')) THEN
Z=Z+1
A(Z:Z)=U
END IF
10 CONTINUE
IF(Z .LT. LTH) A(Z+1:)=' '
RETURN
END
SUBROUTINE SUBSTI(SOURCE,STRA,STRB,NUM)
IMPLICIT INTEGER(A-Z)
CHARACTER*(*) SOURCE,STRA,STRB
C
CHARACTER*255 GAUCHE,DROITE
C
IF(NUM .GE. 0) THEN
ZA=LEN(STRA)
ZB=LEN(STRB)
ELSE
ZA=TRIMLN(STRA)
ZB=TRIMLN(STRB)
END IF
GAUCHE=SOURCE
DO 60 Y=1,ABS(NUM)
Z=INDEX(GAUCHE,STRA)
IF(Z .EQ. 0) GO TO 70
DROITE=GAUCHE(Z+ZA:)
GAUCHE(Z:)=STRB
GAUCHE(Z+ZB:)=DROITE
60 CONTINUE
70 CONTINUE
SOURCE=GAUCHE
RETURN
END
FUNCTION MINDEX(A,B)
IMPLICIT INTEGER(A-Z)
CHARACTER*(*) A,B
MINDEX=INDEX(A,B)
IF(MINDEX .EQ. 0) MINDEX=1+TRIMLN(A)
RETURN
END